perm filename LINEW.F4[RST,LCS] blob sn#085797 filedate 1974-02-02 generic text, type T, neo UTF8
00100		SUBROUTINE LINES(I)
00110	  
00200		COMMON/FU/FUJ(512),JJX,RDIV,ADML/MEDGE/MC,MD,RMC,MMD
00300		COMMON/DRW/JDRW(2000)
00400		EQUIVALENCE(KNT,JDRW(1))
00500		COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
00555		1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
00610		DATA IFLIP/-1/,RDIV/.5/,FUJ(1)/99./
00615		CALL SWITCH
00617	C REVERSE OR INVERT (IN 'SWITCH') HAPPEN BEFORE DISTORTION OR ROTATE.
00620		IF(FUJ(1).EQ.99)GO TO 31
00625		RX=JA*RMC+1
00630		IF(RX.GT.512.)RX=512.
00636		IF(ADML.GE.0)GO TO 32
00637		JB=JB+MMD*FUJ(IFIX(RX))
00638	C  'CENTR' IS MULT FOR ADDING!  (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
00639		GO TO 31
00650	32	NY=JB-MMD
00680		JB=MMD+NY*FUJ(IFIX(RX))
00705	31	IF(ROT.LE.1)GO TO 9
00710		RX=JA
00715		RY=JB
00720		AX=ATAN2(RY,RX)*57.29578
00725		HYP=SQRT(RX**2+RY**2)
00730		RT=ROT+AX
00735		JA=HYP*COSD(RT)
00740		JB=HYP*SIND(RT)
00745		GO TO 10
00800	9	IF(ROT.GT.0)CALL EXCH(JA,JB)
00900	10	JA=JA+JX
01000		JB=JB+JY
01100	C  IF ROT.GE.0 ROTATE 90 DEG. TO LEFT
01200		M=JA
01300		N=JB
01400		IF(PLT)GO TO 1
01500	6	M=M-JAR
01600		N=N-JBR
01700	CC2	TYPE 20,M,N,JX,JY
01800	20	FORMAT(4I6)
01900		IF(I.EQ.3)GO TO 3
02000		CALL RVECT(M,N)
02100	5	JAR=JA
02200		JBR=JB
02300		RETURN
02400	3	CALL RIVECT(M,N)
02500		GO TO 5
02600	
02700	CC1	TYPE 20,M,N,JX,JY
02800	1	IF(PLT.EQ.-2)GO TO 4
02900		CALL PLOT(M,N,I)
03000		RETURN
03050	4	IFLIP=-IFLIP
03060		IF(I.EQ.3)GO TO 7
03100		IF(KNT.GE.200.OR.IFLIP)RETURN
03110		GO TO 70
03155	7	IF(JDRW(KNT).GT.100000000)GO TO 71
03200	70	KNT=KNT+1
03220	71	M=M/8
03240		N=N/8
03410		IF(M.NE.KM)GO TO 56
03420		IF(IABS(N-KN).GT.1)GO TO 55
03425		IF(N.EQ.KN)GO TO 59
03430	57	IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
03440		GO TO 58
03450	56	IF(N.NE.KN)GO TO 55
03460		IF(IABS(M-KM).LE.1)GO TO 57
03500		GO TO 55
03600	59	IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
03700		RETURN
03710	55	IF(I.NE.3)GO TO 11
03711		KM=10000
03712		GO TO 8
03715	11	IF(M-KM.NE.LM.OR.N-KN.NE.LN)GO TO 8
03717		IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
03720	8	LN=N-KN
03725		LM=M-KM
03800		KM=M
03900		KN=N
03910	58	M=(M-50)*10000
03915		N=N-50
04000		IF(M)M=10000000-M
04100		IF(N)N=1000-N
04200		IF(I.EQ.3)M=M+100000000
04300		JDRW(KNT)=M+N
04350		IF(JDRW(KNT).EQ.0)KNT=KNT-1
04400		END
04500	
04600		SUBROUTINE EXCH(J,K)
04700		I=J
04800		J=K
04900		K=I
05000		END
05100	
05200		SUBROUTINE JZERO
05300		COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
05400		1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
05500		JAR=0
05600		JBR=0
05700		END
05800	
05900		SUBROUTINE DSTORT(JPL)
06000		COMMON/MEDGE/MC,MD,RMC,MMD/FU/FUJ(512),JJX,RDIV,ADML
06100		MMD=(MD/JPL)*RDIV
06150		IF(ADML)MMD=RDIV*(MD/JPL)
06151	C  'CENTR' IS MULT FOR ADDING!  (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
06200		RMC=MC
06300		RMC=511./(RMC/JPL)
06400		END
06500	
06600		SUBROUTINE INVIS(MA,MB,MC,MD,N)
06700		DIMENSION LL(100)
06800		COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
06900		1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
07000		CALL JZERO
07100		NA=MA/3
07200		NB=MB/3
07300		NC=MC/3
07400		ND=MD/3
07500		IF(N.EQ.0)N=-1
07600		IF(N)CALL DPYSET(2,LL,100)
07700		N=1
07800		CALL JZERO
07900		CALL DPYBRT(2)
08000	1	CALL AIVECT(-380,-200)
08100		JA=NA
08200		JB=NC
08300		CALL LINES(3)
08400		JB=NC
08500		JA=NB
08600		CALL LINES(2)
08700		JB=ND
08800		JA=NB
08900		CALL LINES(2)
09000		JA=NA
09100		JB=ND
09200		CALL LINES(2)
09300		JA=NA
09400		JB=NC
09500		CALL LINES(2)
09600		CALL JZERO
09700	6683	CALL DPYOUT(2)
09800		END
09900	
09950		SUBROUTINE SWITCH
10000		COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
10100		1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
10200		IF(REV.NE.0)JA=JREV-JA
10300		IF(RINV.NE.0)JB=JINV-JB
10400		END
10500	
10600		SUBROUTINE DPFUN(JFU)
10700		COMMON/FU/FUJ(512),JJX,RDIV,ADML/DRW/LIST(2000)
19000	13	IF(JFU.NE.' ')GO TO 19
19100		TYPE 14
19200	14	FORMAT(' FUNC FILE NAME?  ',$)
19300	15	FORMAT(8F)
19350	83	FORMAT(A5)
19400		ACCEPT 83,JFU
19500		IF(JFU.NE.' ')GO TO 19
19600		FUJ(1)=99.
19700	C  A BLANK DELETES FUNC ACTION.
19800		RETURN
19900	19	REWIND 1
20000		CALL IFILE(1,JFU)
20100		DO 17 K=1,3
20200	17	READ(1,18)A,B,B
20300	18	FORMAT(3A5)
20400	16	READ(1,15)A,B
20500		IF(B.NE.520.0)GO TO 16
20600		READ(1,15)FUJ
20700		CALL DPYSET(3,LIST,500)
20800		CALL ALINE(306,300,476,300)
20900		CALL ALINE(306,215,306,385)
21000	CC	CALL AIVECT(0,0)
21100		KY=FUJ(1)*85.0+300.
21200		CALL AIVECT(306,KY)
21300		DO 32 K=2,512,3
21400		KY2=FUJ(K)*85.0+300.
21500		CALL RVECT(1,KY2-KY)
21600	32	KY=KY2
21700		CALL DPYOUT(3)
21800		END
22000		SUBROUTINE DD
22100		COMMON/DRW/JDRW(2000)
23000	3	REWIND 21
23100	6	K=JDRW(1)+1
23200		
23300		IF(K.LE.201)GO TO 5
23400		JDRW(1)=200
23500		K=201
23600	5	WRITE(21,120)K
23700	120	FORMAT(' 9999  1 ',I4,' 0 0 0 0 0 0 0 0')
23800		J=7
23900		L=8
24000		DO 12 K=1,JDRW(1),8
24100		IF(K+J.LT.JDRW(1))GO TO 12
24200		J=JDRW(1)-K
24300		L=J+1
24400	12	WRITE(21,11)L,(JDRW(N),N=K,K+J)
24500		CALL EXIT
24600	11	FORMAT(' 9999',I3,8I10)
24700		END